Introduction

The Simpsons is the world’s longest-running animated sitcom, and it was created by the American writer Matt Groening. It is a satirical depiction of the working-class life of the Simpson family, which consists of Homer, Marge, Bart, Lisa, and Maggie. The show is set in the fictional town of Springfield, and it parodies culture, society, and the human condition.

This report illustrates an exploratory and text analysis of the many data sets about the show available at the data science platform Kaggle and the #tidytuesday Github repository. Let us start by loading the required packages.

library(tidyverse)
library(readr)
library(kableExtra)
library(treemapify)
library(gridExtra)
library(ggpubr)
library(tidytext)
library(RColorBrewer)
library(tm)
library(topicmodels)
library(scales)
library(treemap)
library(igraph)
library(ggraph)
library(ggwordcloud)
library(udpipe)
library(ggcorrplot)
library(GGally)
theme_set(theme_bw())

show_table <- function(x, caption ="", head = 50, scroll = FALSE, full.width = FALSE, 
                       digits = 2, col.names = NA, align = NULL){
  table <- x %>%
    head(head) %>%
    kable(caption = caption, digits = digits, col.names = col.names, align = align,
          format.args = list(decimal.mark = ".", big.mark = ",")) %>%
    kable_styling("striped", position = "left", full_width = full.width)
    if(scroll){
      table <- table %>%
        scroll_box(width = "100%", height = "500px")
    }
  return(table)
}

firstup <- function(x) {
  substr(x, 1, 1) <- toupper(substr(x, 1, 1))
  x
}

colors  <- c('#fed41d', '#0094c7', '#f14e28')
palette <- c("#acba81ff", "#2a9430ff", "#ae6b1bff","#024CF0", "#28536bff", "#68aedeff", "#8928e8ff",
             "#f25d30ff", "#d63d2aff", "orchid", "#b49ba0ff", "darkorange", "#ef4d8bff", "#ffc510ff",
             "lightsalmon1", "azure4", "aquamarine3")

The five data sets we will be working with are simpsons_characters.csv, simpsons_locations.csv, simpsons_script_lines.csv, simpsons_episodes.csv, and simpsons-guests.csv.

characters <- read_delim("Data/simpsons_characters.csv", delim = ",")
locations  <- read_delim("Data/simpsons_locations.csv", delim = ",")
episodes   <- read_delim("Data/simpsons_episodes.csv", delim = ",")
dialogues  <- read_delim("Data/simpsons_script_lines.csv", delim = ",")
guests     <- read_delim("https://raw.githubusercontent.com/rfordatascience/tidytuesday/master/data/2019/2019-08-27/simpsons-guests.csv", delim = "|", quote = "")

Locations

The following treemap depicts the 20 most common locations, that is, the settings where the characters had the most dialogue. At the top, we find The Simpson home, followed by Springfield Elementary School, and Moe’s Tavern. The majority of these locations denote indoor settings.

dialogues.tidy %>%
  count(location, sort = TRUE) %>%
  head(20) %>%
  add_column("Space" = c(rep("Indoor", 8), rep("Outdoor", 3), rep("Indoor", 3), "Outdoor",
                         rep("Indoor", 3), "Outdoor", "Indoor")) %>%
  mutate(Space = as.factor(Space)) %>%
  ggplot(aes(area = n, label = location, fill = Space, subgroup = location)) +
  geom_treemap( alpha = 0.8) +
  geom_treemap_subgroup_border(color = "black", size = 0.85) +
  geom_treemap_text(place = "centre", size = 13,
                    grow = FALSE, reflow = TRUE) +
  scale_fill_manual(values = c("#62AF67ff", "#989DCDff")) +
  theme(legend.position = "bottom") +
  labs(title = "Top 20 locations",
       subtitle = "Most dialogues take place at the Simpson home, and indoor.")

Let us select the six most recurrent locations, and explore which characters have the most dialogue therein.

• Simpson home: it is the house of the Simpson family. The most talkative characters here are of course the Simpson family members.

• Springfield Elementary School: it is the local school on The Simpsons, attended by Bart and Lisa Simpson. Besides the two of them, other leading characters include the principal Skinner, the superintendent Chalmers and the teacher Edna.

• Moe’s Tavern: it is the local bar in Springfield. The dialogue here mostly occurs between the owner Moe and his guests Homer, Lenny, Carl, and Barney.

• Springfield Nuclear Power Plant: it is the nuclear power plant in Springfield. The leading characters here are Mr. Burns, who owns the plant, his executive assistant Smithers, and the employees Homer, Lenny, and Carl.

• Kwik-E-Mart: it is the convenience store run by Apu. The dialogues here usually involve the owner of the store and the members of the Simpson family.

• First Church of Springfield: it is the main religious house in Springfield. Most of the dialogues here occur between the Reverend, the Simpson family, and their very religious next-door neighbor Ned.

top.locations <- dialogues.tidy %>%
  count(location, word, sort = TRUE) %>%
  group_by(location) %>%
  summarize(n = n()) %>%
  arrange(desc(n)) %>%
  top_n(6, n) %>%
  pull(location)

set.seed(2)
dialogues.tidy %>%
  filter(location %in% top.locations) %>%
  count(role, location, sort = TRUE) %>%
  group_by(location) %>%
  top_n(5, n) %>%
  ungroup() %>%
  mutate(location = fct_reorder(location, -n, sum)) %>%
  ggplot(aes(reorder_within(role, n, location), n, fill = fct_reorder(role, n, sum))) +
  geom_col(show.legend = FALSE) +
  coord_flip() +
  facet_wrap(~location, scales = "free") +
  scale_fill_manual(values = sample(palette)) +
  labs(title = "Who speaks the most where?", x = "", y = "")  +
  scale_y_continuous(labels = comma) +
  theme(panel.spacing = unit(0.5, "lines")) +
  scale_x_reordered()

The following plot depicts the distribution of the total number of words per season pronounced by the four Simpsons family members Homer, Marge, Bart, and Lisa through density plots. Whereas Homer Simpson stands out from any other character, the other three Simpson characters seem to have had comparable degrees of importance over the seasons.

Top20Chars <- dialogues.tidy %>%
  count(role, word, sort = TRUE) %>%
  distinct(role) %>%
  head(20) %>%
  pull(role)

dialogues.tidy %>%
  filter(role %in% Top20Chars[1:4]) %>%
  group_by(season, role) %>%
  summarize(nwords = n()) %>%
  ungroup() %>%
  mutate(role = reorder(role, -nwords)) %>%
  ggplot(aes(x=nwords, fill = fct_rev(role), color = fct_rev(role))) +
  geom_density(size = 0.85, alpha = 0.65)  +
  scale_x_continuous(labels = comma) +
  labs(x = "Number of words per season", y = "Density",
       title = "Distribution of the total number of words per season") +
  guides(fill = guide_legend(reverse = TRUE), color = guide_legend(reverse = TRUE)) +
  scale_fill_manual(name = "Character", values = rev(palette[c(8,14,6,1)])) +
  scale_color_manual(name = "Character", values = rev(palette[c(8,14,6,1)])) +
  theme(legend.position = "bottom")

Episodes

Let us have a look at the trend of the ratings, the number of votes, and the TV views across episodes and averaged over seasons. We notice an overall downward for all three indicators. Older seasons are the most appreciated, most rated, and most viewed. As a matter of fact, the Simpsons show received acclaim throughout its first nine or ten seasons, which are generally considered its “Golden Age”, but was criticized for a perceived decline in quality over the years.

Concerning the downward trend observed for TV views though, the availability in more recent years of a variety of TV channels and Internet streaming platforms has caused a drop in the views not only for The Simpsons but also for many other network TV shows.

scatter_plot <- function(df, x, y, xlab = "Original air date", ylab, title,
                      breaks = NULL, limits = NULL, labels  = comma){
  x <- enquo(x)
  y <- enquo(y)

  p <- df %>%
    ggplot(aes(!! x, !! y)) +
    geom_point(size = 0.6) +
    geom_smooth(method = "loess", formula = "y ~ x") +
    labs(x = xlab, y = ylab, title = title)
  if(!is.null(breaks)){
    p <- p +
    scale_y_continuous(labels = labels, breaks = breaks, limits = limits)
  }else{
    p <- p +
    scale_y_continuous(labels = labels, limits = limits)
  }
  p
}

trend.rating <- episodes %>%
  scatter_plot(year, rating, ylab = "Rating score", title = "IMDb ratings",
               breaks = seq(0, 10, 2), limits = c(1, 10))

trend.votes <- episodes %>%
  scatter_plot(year, votes, ylab = "Number of votes", title = "IMDb votes",
               limits = c(0, 4000))

trend.views <- episodes %>%
  scatter_plot(year, us_views, ylab = "Number of US viewers", title = "TV views in the US",
               limits = c(0, 35), labels = unit_format(unit = "", scale = 1e+6, big.mark = ","))

grid.arrange(trend.rating, trend.votes, trend.views, nrow = 1, ncol = 3, widths = c(0.95, 0.97, 1.08))

line_plot <- function(data, x, y, xlab = "Season", ylab, title, sub,
                      limits = NULL, breaks = NULL, labels = comma){

  x <- enquo(x)
  y <- enquo(y)

  p <- data %>%
    ggplot(aes(!! x, !! y)) +
    geom_line(size = 1.2, color = "#8d99ae") +
    geom_point(shape=21, color=colors[2], fill=colors[2], size=1) +
    scale_x_continuous(breaks = seq(1, 27, 4)) +
    labs(x = xlab, y = ylab, title = title, subtitle = sub) +
    theme(plot.subtitle=element_text(size=9))
    if(!is.null(breaks)){
     p <- p +
       scale_y_continuous(labels = labels, breaks = breaks, limits = limits)
    }else{
     p <- p +
       scale_y_continuous(labels = labels, limits = limits)
    }
  p
}

episodes_byseason <- episodes %>%
  group_by(season) %>%
  summarize(avg_rate  = mean(rating),
            avg_vote  = mean(votes),
            avg_views = mean(us_views))

plot.rating <- episodes_byseason %>%
  line_plot(season, avg_rate, ylab = "Rating score",  title = "IMDb ratings",
            sub = "Averaged by season \nOlder seasons are the most appreciated.",
            breaks = seq(0, 10, 2), limits = c(1,10))

plot.vote <- episodes_byseason %>%
  line_plot(season, avg_vote, ylab = "Number of voters", title = "IMDb votes",
            sub = "Averaged by season \nOlder seasons are the most rated.",
            limits = c(0, 2000))

plot.view <- episodes_byseason %>%
  line_plot(season, avg_views, ylab = "Number of viewers", title = "TV views in the US",
            sub = "Averaged by season \nOlder seasons are the most viewed.",
            labels = unit_format(unit = "", scale = 1e+6, big.mark = ","),
            limits = c(0, 30))

grid.arrange(plot.rating, plot.vote, plot.view, nrow = 1,
             widths = c(0.95, 0.97, 1.08))

The plots below show the distributions and the pairwise-relationships between IMDb ratings, IMDb votes, and TV views in the US. There seems to be a positive linear relationship between each pair of them.

line_smooth <- function(data, mapping, method="loess", ...){
  p <- ggplot(data = data, mapping = mapping) +
    geom_point(...) +
    geom_smooth(method=method)
  p
}
bi_density_plot <- function(data, mapping, palette = 4, ...){
  p <- ggplot(data, mapping = mapping) +
    stat_density_2d(aes(fill = stat(level)), geom = "polygon") +
    scale_fill_distiller(palette = palette, direction = 1)
  p
}

episodes %>%
  select("IMDb rating" = rating, "IMDb votes" = votes, "TV views in US (millions)" = us_views) %>%
  ggpairs(upper = list(continuous = wrap(bi_density_plot, palette = 1, size = 0.2)),
          diag  = list(continuous = wrap("barDiag", fill = "#8d99ae", bins = 27)),
          lower = list(continuous = wrap(line_smooth, color = "black", size = 0.2))) +
  ggtitle(label = "Pairwise variable comparisons")

The graphical representation of the correlation matrix of episodes shows a strong inverse relationship between the episode number and the ratings, the votes, and the views. This indicates that more recent seasons are generally characterized by a decrease in those performance indicators. These indicators are also strongly correlated to one another, meaning that when one of those increases, so do the other two.

episodes %>%
  select("Episode number" = episode_id, "IMDb rating" = rating,
         "IMDb votes" = votes, "TV views in US" = us_views) %>%
  cor() %>%
  ggcorrplot(type = "lower", colors = c("#6D9EC1", "white", "#E46726"), outline.col = "white",
             legend.title = "Correlation", lab = TRUE, ggtheme = ggplot2::theme_light()) +
  labs(title = "Correlation matrix")

Text analysis

Let us now carry out some text analysis on dialogues. In this scenario, the episodes of the show are acting as the documents of the corpus.

dialogues.tidy <- dialogues.tidy %>%
  anti_join(stop_words, by = "word")

dialogues.summarized <- dialogues.tidy %>%
  distinct(role, line_number, word) %>%
  count(role, word, sort = TRUE)

dialogues.summarized %>%
  show_table(head = 15, col.names = c("Character", "Word", "Frequency"),
             align = c("l", "r", "r"))

role.specificity <- dialogues.summarized %>%
  group_by(role) %>%
  mutate(total_words = sum(n)) %>%
  ungroup() %>%
  bind_tf_idf(word, role, n) %>%
  arrange(desc(tf_idf))

role.specificity %>%
  filter(total_words >= 500) %>%
  distinct(role, .keep_all = TRUE) %>%
  mutate(role_word = paste0(role, ": ", word)) %>%
  head(20) %>%
  mutate(role_word = fct_reorder(role_word, tf_idf)) %>%
  ggplot(aes(role_word, tf_idf)) +
  geom_segment(aes(role_word, xend = role_word, y = 0, yend = tf_idf),
               color = "#8d99ae", size = 0.8, show.legend = FALSE) +
  geom_point(color = "#8d99ae", size = 4, alpha = 0.6) +
  coord_flip() +
  labs(title = "Using TF-IDF as a catchphrase detector",
       subtitle = "Top 20 characters speaking at least 500 words in 27 seasons.",
       x = "", y = "TF-IDF")

dialogue_bigram <- dialogues %>%
  unnest_tokens(bigram, line, token = "ngrams", n = 2)

dialogue_filtered <- dialogue_bigram %>%
  separate(bigram, c("word1", "word2"), sep = " ") %>%
  filter(!word1 %in% stop_words$word & !is.na(word1)) %>%
  filter(!word2 %in% stop_words$word & !is.na(word2))

bigram_counts <- dialogue_filtered %>%
  count(word1, word2, sort = TRUE)

bigram_united <- dialogue_filtered %>%
  unite(bigram, word1, word2, sep = " ")

bigram_united %>%
  count(bigram, sort = TRUE) %>%
  show_table(head = 10, col.names = c("Bigram", "Frequency"),
             caption = "Top 10 bigrams throughout 26 seasons", align = c("l", "r"))

bigram_tf_idf <- bigram_united %>%
  count(role, bigram) %>%
  bind_tf_idf(bigram, role, n) %>%
  arrange(desc(tf_idf))

bigram_tf_idf %>%
  filter(n > 50) %>%
  distinct(role, .keep_all = TRUE) %>%
  show_table(col.names = c("Character", "Bigram", "Frequency", "tf", "idf", "tf-idf"),
             align = c("l", rep("r", 5)), 
             caption = "Peculiar bigrams occurring over 50 times throughout 26 seasons")

bigram.graph <- bigram_counts %>%
  filter(n > 30) %>%
  graph_from_data_frame()

set.seed(1234)
a <- grid::arrow(type = "closed", length = unit(.15, "inches"))

ggraph(bigram.graph, layout = "fr") +
  geom_edge_link(aes(edge_alpha = n), show.legend = FALSE,
                 arrow = a, end_cap = circle(.07, "inches")) +
  geom_node_point(color = "lightblue", size = 5) +
  geom_node_text(aes(label = name), vjust = 1, hjust = 1) +
  theme_void()

simpsons_sentiments <- dialogues.tidy %>%
  inner_join(get_sentiments("bing"), by = "word")

bar_chart_sentiment <- function(df, x = NULL, y, z, slice = NULL, count = TRUE){

  y <- enquo(y)
  z <- enquo(z)

  if(count){
    x <- enquo(x)
    df <-   df %>%
      count(!! x, !! y, !! z) %>%
      mutate(n = ifelse(!! z == "negative", -n, n),
             !! x := reorder(!! x, -abs(n), sum),
             !! y := reorder_within(!! y, n, !! x)) %>%
      group_by(!! x) %>%
      arrange(desc(abs(n)))
  }
  
  if(!is.null(slice)){
    df <- df %>%
      slice(slice)
  }
  
  df %>%
    ggplot(aes(!! y, n, fill = !! z)) +
    geom_bar(stat = "identity") +
    coord_flip() +
    scale_fill_manual(name = "Sentiment", values = c("#f1776a", "#8bc384")) +
    labs(x = "Word", y = "Contribution to sentiment") +
    scale_x_reordered() +
    theme(legend.position = "bottom")
}

simpsons_sentiments %>%
  count(sentiment, word) %>%
  ungroup() %>%
  filter(n > 400) %>%
  mutate(n = ifelse(sentiment == "negative", -n, n)) %>%
  mutate(word = reorder(word, n)) %>%
  bar_chart_sentiment(y = word, z = sentiment, count = FALSE)

simpsons_sentiments %>%
  filter(role %in% Top20Chars[1:6]) %>%
  bar_chart_sentiment(x = role, y = word, z = sentiment, slice = c(1:12)) +
  facet_wrap(~ role, scales = "free")